#!/usr/bin/perl -wc

package RFCMail::Common::Grammar;

use strict;
use base qw(Exporter);
use Carp qw(croak);

my @CORE_REGEX =
    qw( ALPHA_RE BIT_RE CHAR_RE CR_RE CRLF_RE CTL_RE DIGIT_RE
	DQUOTE_RE HEXDIG_RE HTAB_RE LF_RE LWSP_RE OCTET_RE SP_RE
	VCHAR_RE WSP_RE );

my @COMMON_REGEX =
    qw( NO_WS_CTL_RE TEXT_RE QUOTED_PAIR_RE ATEXT_RE QTEXT_RE
	QCONTENT_RE );

my @FUNCTIONS =
    qw( is_quotable encode_quoted_string encode_quoted_string_nsc
	encode_date_time gen_date_time_z gen_date_time gen_id
	encode_msg_id gen_msg_id );

our @EXPORT = (@CORE_REGEX, @COMMON_REGEX, @FUNCTIONS);

our %EXPORT_TAGS =
    (
     core_regex => \@CORE_REGEX,
     common_regex => \@COMMON_REGEX,
     functions => \@FUNCTIONS,
    );


# This module is for regular expressions and simple functions related
# to ABNF (RFC 2234), plus elements common to other mail standards
# such as SMTP (RFC 2821), and MAIL (RFC 2822).


# "Core Rules" from RFC 2234, Appendix A.  Many of these are less
# convenient to use than the Perl regex they represent.  Don't feel
# obliged to use them if they don't aid (read/writ)ability.

use constant ALPHA_RE => qr'[[:alpha:]]';
use constant BIT_RE => qr'[01]';
use constant CHAR_RE => qr'[\x01-\x7F]';
use constant CR_RE => qr'\x0D';
use constant CRLF_RE => qr'\x0D\x0A';
use constant CTL_RE => qr'[\x00-\x1F\x7F]';
use constant DIGIT_RE => qr'\d';
use constant DQUOTE_RE => qr'\x22';
use constant HEXDIG_RE => qr'[[:xdigit:]]';
use constant HTAB_RE => qr'\x09';
use constant LF_RE => qr'\x0A';
use constant LWSP_RE => qr'(?:(?:\x0D\x0A)?[\x20\x09])*';
use constant OCTET_RE => qr'\C';
use constant SP_RE => qr'\x20';
use constant VCHAR_RE => qr'[\x21-\x7E]';
use constant WSP_RE => qr'[\x20\x09]';


# MAIL defines certain tokens used by SMTP. Those tokens (and those
# more fundamental) are defined here.  Note that constructs marked as
# obsolete are excluded.

# RFC 2822, section 3.2.1: "Primitive Tokens"
use constant NO_WS_CTL_RE => qr'[\x01-\x08\x0B\x0C\x0E-\x1F\x7F]';
use constant TEXT_RE => qr'[\x01-\x09\x0B\x0C\x0E-\x7F]';

# RFC 2822, section 3.2.2: "Quoted characters"
use constant QUOTED_PAIR_RE => qr"\\\\@{[TEXT_RE]}";

# RFC 2822, section 3.2.3: "Folding white space and comments".
# Although these tokens are used in SMTP, there is never any need to
# parse them, only generate them, so I'll consider them MAIL-specific
# for the purposes of packaging.

# RFC 2822, section 3.2.4: "Atom"
use constant ATEXT_RE => qr'[[:alnum:]!#$%&\'*+/=?^_`{|}~-]';
# The remaining items in this section have divergent definitions in SMTP.

# RFC 2822, section 3.2.5: "Quoted strings"
use constant QTEXT_RE => qr'[\x01-\x08\x0B\x0C\x0E-\x1F\x21\x23-\x5B\x5D-\x7F]';
use constant QCONTENT_RE => qr"@{[QTEXT_RE]}|@{[QUOTED_PAIR_RE]}";
# "quoted-string" is omitted because it has a divergent definition in SMTP.


# Grammar element checking/generating functions, suitable for SMTP and
# MAIL (and probably some others too).

sub is_quotable {
    return ($_[0] !~ /[\000\012\015\200-\377]/);
}


sub encode_quoted_string_nsc {
    my ($arg) = @_;
    $arg =~ s/([\001-\037 \\\"])/\\$1/g;
    return (qq("$arg"));
}


sub encode_quoted_string {
    croak("Argument to encode_quoted_string() cannot be encoded")
	unless &is_quotable;
    return (&encode_quoted_string_nsc);
}


sub encode_date_time {
    my ($zone, $sec, $min, $hour, $mday, $mon, $year, $wday) = @_;
    $year += 1900;
    $mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec)[$mon];
    $wday = qw(Sun Mon Tue Wed Thu Fri Sat)[$wday];
    return (sprintf("%s, %d %s %04d %02d:%02d:%02d %s",
		    $wday, $mday, $mon, $year, $hour, $min, $sec, $zone));
}


sub gen_date_time_z {
    my ($time) = (@_, time());
    return (encode_date_time("-0000", gmtime($time)));
}


sub gen_date_time {
    my ($time) = (@_, time());
    my $result = eval {
	require Time::Zone;
	use integer;
	my $s = Time::Zone::tz_local_offset();
	my $h = $s / 3600;
	my $m = abs($s % 3600) / 60;
	encode_date_time(sprintf("%+03d%02d", $h, $m), localtime($time))
    };
    return (defined($result) ? $result : gen_date_time_z($time));
}


my $wrap_counter = 0;
my $last_time = 0;
sub gen_id {
    my $time = time();
    if ($time != $last_time) {
	$last_time = $time;
	$wrap_counter = int(rand(0x7FFF));
    }
    $wrap_counter = ($wrap_counter + 1) & 0xFFFF;
    return (sprintf("%08X-%04X-%04X", $time, $$, $wrap_counter));
}


sub encode_msg_id {
    return (sprintf('<%s@%s>', @_));
}


our $id_right;
sub gen_msg_id {
    croak('gen_msg_id() called without argument and without defining $id_right')
	if not @_ and not defined($id_right);
    return (encode_msg_id(gen_id(), @_, $id_right));
}


1;
